home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / psgml / psgml-xemacs.el.z / psgml-xemacs.el
Encoding:
Text File  |  1998-05-21  |  6.9 KB  |  256 lines
  1. ;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support
  2. ;; $Id: psgml-xemacs.el,v 2.3 1996/03/31 21:32:12 lenst Exp $
  3.  
  4. ;; Copyright (C) 1994 Lennart Staflin
  5.  
  6. ;; Author: Lennart Staflin <lenst@lysator.liu.se>
  7. ;;       William M. Perry <wmperry@indiana.edu>
  8. ;; Synced up with Ben Wing's changes for XEmacs 19.14 by
  9. ;;       Steven L Baur <steve@miranova.com>
  10.  
  11. ;; 
  12. ;; This program is free software; you can redistribute it and/or
  13. ;; modify it under the terms of the GNU General Public License
  14. ;; as published by the Free Software Foundation; either version 2
  15. ;; of the License, or (at your option) any later version.
  16. ;; 
  17. ;; This program is distributed in the hope that it will be useful,
  18. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;; GNU General Public License for more details.
  21. ;; 
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with this program; if not, write to the Free Software
  24. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26.  
  27. ;;;; Commentary:
  28.  
  29. ;;; Part of psgml.el
  30.  
  31. ;;; Menus for use with XEmacs
  32.  
  33.  
  34. ;;;; Code:
  35.  
  36. (require 'psgml)
  37. ;;(require 'easymenu)
  38.  
  39. (eval-and-compile
  40.   (autoload 'sgml-do-set-option "psgml-edit"))
  41.  
  42. (defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
  43.   "*Max number of entries in Tags and Entities menus before they are split
  44. into several panes.")
  45.  
  46. ;;;; Pop Up Menus
  47.  
  48. (defun sgml-popup-menu (event title entries)
  49.   "Display a popup menu."
  50.   (setq entries
  51.     (loop for ent in entries collect
  52.           (vector (car ent)
  53.               (list 'setq 'value (list 'quote (cdr ent)))
  54.               t)))
  55.   (cond ((> (length entries) sgml-max-menu-size)
  56.      (setq entries
  57.            (loop for i from 1 while entries collect
  58.              (let ((submenu
  59.                 (subseq entries 0 (min (length entries)
  60.                            sgml-max-menu-size))))
  61.                (setq entries (nthcdr sgml-max-menu-size
  62.                          entries))
  63.                (cons
  64.             (format "%s '%s'-'%s'"
  65.                 title
  66.                 (sgml-range-indicator (aref (car submenu) 0))
  67.                 (sgml-range-indicator
  68.                  (aref (car (last submenu)) 0)))
  69.             submenu))))))
  70.   (sgml-xemacs-get-popup-value (cons title entries)))
  71.  
  72.  
  73. (defun sgml-range-indicator (string)
  74.   (substring string
  75.          0
  76.          (min (length string) sgml-range-indicator-max-length)))
  77.  
  78.  
  79. (defun sgml-xemacs-get-popup-value (menudesc)
  80.   (let ((value nil)
  81.     (event nil))
  82.     (popup-menu menudesc)
  83.     (while (popup-up-p)
  84.       (setq event (next-command-event event))
  85.       (cond ((menu-event-p event)
  86.          (cond
  87.           ((eq (event-object event) 'abort)
  88.            (signal 'quit nil))
  89.           ((eq (event-object event) 'menu-no-selection-hook)
  90.            nil)
  91.           ((commandp (event-object event))
  92.            (call-interactively (event-object event))
  93.            (signal 'quit nil))
  94.           (t
  95.            (eval (event-object event)))))
  96.         ((button-release-event-p event) ; don't beep twice
  97.          nil)
  98.         ;; [sb] added condition
  99.         ((and (fboundp 'event-matches-key-specifier-p)
  100.           (event-matches-key-specifier-p event (quit-char)))
  101.          (signal 'quit nil))
  102.         (t
  103.          (beep)
  104.          (message "please make a choice from the menu."))))
  105.     value))
  106.  
  107. (defun sgml-popup-multi-menu (pos title menudesc)
  108.   "Display a popup menu.
  109. MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
  110. ITEM should have to form (STRING EXPR) or STRING.  The EXPR gets evaluated
  111. if the item is selected."
  112.   (popup-menu
  113.    (cons title
  114.      (loop for menu in menudesc collect
  115.            (cons (car menu)        ; title
  116.              (loop for item in (cdr menu) collect
  117.                (if (stringp item)
  118.                    item
  119.                  (vector (car item) (cadr item) t))))))))
  120.  
  121.  
  122. ;;;; XEmacs menu bar
  123.  
  124. (defun sgml-make-options-menu (vars)
  125.   (loop for var in vars 
  126.     for type = (sgml-variable-type var)
  127.     for desc = (sgml-variable-description var)
  128.     collect
  129.     (cond
  130.      ((eq type 'toggle)
  131.       (vector desc (list 'setq var (list 'not var))
  132.           ':style 'toggle ':selected var))
  133.      ((consp type)
  134.       (cons desc
  135.         (loop for c in type collect
  136.               (if (atom c)
  137.               (vector (prin1-to-string c)
  138.                   (`(setq (, var) (, c)))
  139.                   :style 'toggle
  140.                   :selected (`(eq (, var) '(, c))))
  141.             (vector (car c)
  142.                 (`(setq (, var) '(,(cdr c))))
  143.                 :style 'toggle
  144.                 :selected (`(eq (, var) '(,(cdr c)))))))))
  145.      (t
  146.       (vector desc
  147.           (`(sgml-do-set-option '(, var)))
  148.           t)))))
  149.  
  150.  
  151. (unless (or (not (boundp 'emacs-major-version))
  152.         (and (boundp 'emacs-minor-version)
  153.          (< emacs-minor-version 10)))
  154.   (loop for ent on sgml-main-menu
  155.     if (vectorp (car ent))
  156.     do (cond
  157.         ((equal (aref (car ent) 0) "File Options >")
  158.          (setcar ent
  159.              (cons "File Options"
  160.                (sgml-make-options-menu sgml-file-options))))
  161.         ((equal (aref (car ent) 0) "User Options >")
  162.          (setcar ent
  163.              (cons "User Options"
  164.                (sgml-make-options-menu sgml-user-options)))))))
  165.  
  166.  
  167. ;;;; Key definitions
  168.  
  169. (define-key sgml-mode-map [button3] 'sgml-tags-menu)
  170.  
  171.  
  172. ;;;; Insert with properties
  173.  
  174. (defun sgml-insert (props format &rest args)
  175.   (let ((start (point))
  176.     tem)
  177.     (insert (apply (function format)
  178.            format
  179.            args))
  180.     (remf props 'rear-nonsticky)    ; not useful in XEmacs
  181.  
  182.     ;; Copy face prop from category
  183.     (when (setq tem (getf props 'category))
  184.       (when (setq tem (get tem 'face))
  185.       (set-face-underline-p (make-face 'underline) t)
  186.       (setf (getf props 'face) tem)))
  187.  
  188.     (add-text-properties start (point) props)
  189.  
  190.     ;; A read-only value of 1 is used for the text after values
  191.     ;; and this should in XEmacs be open at the front.
  192.     (if (eq 1 (getf props 'read-only))
  193.     (set-extent-property
  194.      (extent-at start nil 'read-only)
  195.      'start-open t))))
  196.  
  197.  
  198. ;;;; Set face of markup
  199.  
  200. (defun sgml-set-face-for (start end type)
  201.   (let ((face (cdr (assq type sgml-markup-faces)))
  202.     o)
  203.     (loop for e being the extents from start to end
  204.       do (when (extent-property e 'sgml-type)
  205.            (cond ((and (null o)
  206.                (eq type (extent-property e 'sgml-type)))
  207.               (setq o e))
  208.              (t (delete-extent e)))))
  209.  
  210.     (cond (o
  211.        (set-extent-endpoints o start end))
  212.       (face
  213.        (setq o (make-extent start end))
  214.        (set-extent-property o 'sgml-type type)
  215.        (set-extent-property o 'face face)
  216.        (set-extent-property o 'start-open t)
  217.        (set-extent-face o face)))))
  218.  
  219. (defun sgml-set-face-after-change (start end &optional pre-len)
  220.   ;; This should not be needed with start-open t
  221.   (when sgml-set-face
  222.     (let ((o (extent-at start nil 'sgml-type)))
  223.       (cond
  224.        ((null o))
  225.        ((= start (extent-start-position o))
  226.     (set-extent-endpoints o end (extent-end-position o)))
  227.        (t (delete-extent o))))))
  228.  
  229. ;(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el
  230.  
  231. (defun sgml-clear-faces ()
  232.   (interactive)
  233.   (loop for o being the overlays
  234.     if (extent-property o 'type)
  235.     do (delete-extent o)))
  236.  
  237.  
  238. ;;;; Functions not in XEmacs
  239.  
  240. (unless (fboundp 'frame-width)
  241.   (defalias 'frame-width 'screen-width))
  242.  
  243. (unless (fboundp 'frame-height)
  244.   (defalias 'frame-height 'screen-height))
  245.  
  246. (unless (fboundp 'buffer-substring-no-properties)
  247.   (defalias 'buffer-substring-no-properties 'buffer-substring))
  248.  
  249.  
  250. ;;;; Provide
  251.  
  252. (provide 'psgml-xemacs)
  253.  
  254.  
  255. ;;; psgml-xemacs.el ends here
  256.